Developer CD Series 1996 May: Tool Chest/Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso/Tool Chest/Text/WASTE/WASTE 1.1.2 Distribution/WASTE Source/Metrowerks specific/LongCoords⁄Utilities/WEUtilities.p

Text File | 1995-10-12 | 6.3 KB | 283 lines | [TEXT/CWIE]

unit WEUtilities;

{ WASTE PROJECT }
{ Utility Routines }

{ Copyright © 1993-1995 Marco Piovanelli }
{ All Rights Reserved }

interface
    uses
        Types, Memory;

    const

{ result codes }

        weUndefinedSelectorErr = -50;

{ values for WEAllocate allocFlags parameter }

        kAllocClear = $0001;                        { clear handle after allocation }
        kAllocTemp = $0002;                    { use temporary memory if available }

    type

    WEFieldDescriptor = record
            fOffset: Integer;
            fLength: Integer;
        end;  { WEFieldDescriptor }

    WELookupTableElement = record
            selector: LongInt;
            desc: WEFieldDescriptor;
        end;  { WELookupTableElement }
    WELookupTableElementPtr = ^WELookupTableElement;

    WELookupTable = array[0..0] of WELookupTableElement;

    var

{ externally defined global variables }

{$PUSH}
{$J+}

        _weMainSelectorTable: WELookupTable;
        _weObjectHandlerSelectorTable: WELookupTable;

{$POP}

    procedure _WEForgetHandle (var h: univ Handle);
    function _WESetHandleLock (h: univ Handle;
                                    lock: Boolean): Boolean;
    procedure _WEBlockClr (blockPtr: Ptr;
                                    blockSize: Size);
    function _WEBlockCmp (block1, block2: Ptr;
                                    blockSize: Size): Boolean;
    function _WEInsertSlot (h: univ Handle;
                                    element: univ Ptr;
                                    insertAt: LongInt;
                                    slotSize: Size): OSErr;
    function _WERemoveSlot (h: univ Handle;
                                    removeAt: LongInt;
                                    slotSize: Size): OSErr;
    procedure _WEReorder (var a, b: LongInt);
    function _WEGetField ({const} var table: WELookupTable;
                                    selector: OSType;
                                    info: univ Ptr;
                                    structure: univ Ptr): OSErr;
    function _WESetField ({const} var table: WELookupTable;
                                    selector: OSType;
                                    info: univ Ptr;
                                    structure: univ Ptr): OSErr;

implementation

    procedure _WEReorder(var a,b: LongInt);
    var
        temp: LongInt;
    begin
        if (a > b) then
            begin
                temp := a;
                a := b;
                b := temp;
            end;
    end;  { _WEReorder }

    procedure _WEForgetHandle(var h: univ Handle);
    var
        theHandle: Handle;
    begin
        theHandle := h;
        if (theHandle <> nil) then
            begin
                h := nil;
                DisposeHandle(theHandle);
            end;
    end;  { _WEForgetHandle }

    function _WESetHandleLock(h: univ Handle; lock: Boolean): Boolean;
    var
        oldLock: Boolean;
    begin

{ get current lock status (lock bit is the high bit of the handle state byte) }
        oldLock := (HGetState(h) < 0);

{ lock or unlock the handle if necessary }
        if (oldLock <> lock) then
            if (lock) then
                HLock(h)
            else
                HUnlock(h);

{ return previous lock status }
        _WESetHandleLock := oldLock;

    end;  { _WESetHandleLock }

    procedure _WEBlockClr(blockPtr: Ptr; blockSize: Size);
    begin
        while (blockSize > 0) do
            begin
                blockPtr^ := 0;
                blockPtr := Ptr(LongInt(blockPtr) + 1);
                blockSize := blockSize - 1;
            end;  { while }
    end;  { _WEBlockClr }

    function _WEBlockCmp(block1, block2: Ptr; blockSize: Size): Boolean;
    begin
        _WEBlockCmp := false;
        while (blockSize > 0) do
            begin
                if (block1^ <> block2^) then
                    Exit(_WEBlockCmp);
                block1 := Ptr(LongInt(block1) + 1);
                block2 := Ptr(LongInt(block2) + 1);
                blockSize := blockSize - 1;
            end;  { while }
        _WEBlockCmp := true;
    end;  { _WEBlockCmp }

    function _WEInsertSlot (h: univ Handle;
                                    element: univ Ptr;
                                    insertAt: LongInt;
                                    slotSize: Size): OSErr;
    label
        1;
    var
        oldSize: Size;
        offset: LongInt;
        err: OSErr;
    begin

{ get handle size }
    oldSize := InlineGetHandleSize(h);

{ lengthen handle by one "slot" }
    SetHandleSize(h, oldSize + slotSize);
    err := MemError;
    if (err <> noErr) then
        goto 1;

{ calculate insertion offset }
    offset := insertAt * slotSize;

{ make sure offset is within allowed bounds }
    err := -50;
    if ((offset < 0) or (offset > oldSize)) then
        goto 1;

{ make room for new element }
    BlockMoveData(Ptr(LongInt(h^) + offset), Ptr(LongInt(h^) + offset + slotSize), oldSize - offset);

{ insert new element }
    BlockMoveData(element, Ptr(LongInt(h^) + offset), slotSize);

{ clear result code }
    err := noErr;

1:
{ return result code }
    _WEInsertSlot := err;

end;  { _WEInsertSlot }

function _WERemoveSlot (h: univ Handle;
                                removeAt: LongInt;
                                slotSize: Size): OSErr;
label
    1;
var
    newSize: Size;
    offset: LongInt;
    err: OSErr;
begin

{ get handle size minus a "slot" }
    newSize := InlineGetHandleSize(h) - slotSize;

{ calculate removal offset }
    offset := removeAt * slotSize;

{ make sure offset is within allowed bounds }
    err := -50;
    if ((offset < 0) or (offset > newSize)) then
        goto 1;

{ compact the array }
    BlockMoveData(Ptr(LongInt(h^) + offset + slotSize), Ptr(LongInt(h^) + offset), newSize - offset );

{ shorten the handle }
    SetHandleSize(h, newSize);
    err := MemError;
    if (err <> noErr) then
        goto 1;

{ clear result code }
    err := noErr;

1:
{ return result code }
    _WERemoveSlot := err;

end;  { _WERemoveSlot }

    procedure _WELookupSelector(pTable: WELookupTableElementPtr; selector: LongInt; var desc: WEFieldDescriptor);
    begin
        while (pTable^.selector <> selector) do
            begin
                if (pTable^.desc.fLength = 0) then
                    Leave;
                pTable := WELookupTableElementPtr(LongInt(pTable) + SizeOf(WELookupTableElement));
            end;  { while }

        desc := pTable^.desc;
    end;  { _WELookupSelector }

    function _WEGetField ({const} var table: WELookupTable;
                                    selector: OSType;
                                    info: univ Ptr;
                                    structure: univ Ptr): OSErr;
    var
        desc: WEFieldDescriptor;
    begin
        _WEGetField := noErr;

{ look up in the specified look-up table the field descriptor }
{ corresponding to the given selector }
        _WELookupSelector(@table, LongInt(selector), desc);

{ return an error code if the selector isn't defined }
        if (desc.fLength = 0) then
            _WEGetField := weUndefinedSelectorErr
        else
            LongIntPtr(info)^ := LongIntPtr(LongInt(structure) + desc.fOffset)^;

    end;  { _WEGetField }

    function _WESetField ({const} var table: WELookupTable;
                                    selector: OSType;
                                    info: univ Ptr;
                                    structure: univ Ptr): OSErr;
    var
        desc: WEFieldDescriptor;
    begin
        _WESetField := noErr;

{ look up in the specified look-up table the field descriptor }
{ corresponding to the given selector }
        _WELookupSelector(@table, LongInt(selector), desc);

{ return an error code if the selector isn't defined }
        if (desc.fLength = 0) then
            _WESetField := weUndefinedSelectorErr
        else
            LongIntPtr(LongInt(structure) + desc.fOffset)^ := LongIntPtr(info)^;

    end;  { _WESetField }

end.